home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 22 / CU Amiga Magazine's Super CD-ROM 22 (1998)(EMAP Images)(GB)[!][issue 1998-05].iso / PowerPC / Programming / PPCsiod / scm / bi-st-da.s < prev    next >
Encoding:
Text File  |  1993-10-01  |  9.0 KB  |  243 lines
  1.  
  2. (define biblioteca-environment
  3. (make-environment
  4. (define (string-CI<=? x y)
  5.         (or (string-CI<? x y)
  6.             (string-CI=? x y)))
  7. (define (make-persona nome cognome)
  8.         (cons nome cognome))
  9. (define (get-nome-P persona)
  10.         (car persona))
  11. (define (get-cognome-P persona)
  12.         (cdr persona))
  13. (define (input-persona)
  14.         (define cognome (read-string "cognome: "))
  15.         (define nome (read-string "nome: "))
  16.         (make-persona nome cognome))
  17. (define (output-persona persona)
  18.         (writeln "cognome : " (get-cognome-P persona))
  19.         (writeln "nome : " (get-nome-P persona)))
  20. (define (persona=? persona1 persona2)
  21.         (and (string-CI=? (get-nome-P persona1)
  22.                        (get-nome-P persona2))
  23.              (string-CI=? (get-cognome-P persona1)
  24.                        (get-cognome-P persona2))))
  25. (define (persona<=? persona1 persona2)
  26.         (cond ((string-CI<? (get-cognome-P persona1)
  27.                             (get-cognome-P persona2)) #t)
  28.               ((and (string-CI=? (get-cognome-P persona1)
  29.                                  (get-cognome-P persona2))
  30.                     (string-CI<=? (get-nome-P persona1)
  31.                                   (get-nome-P persona2))) #t)
  32.               (else #f)))
  33. (define (make-libro autori titolo)
  34.         (list autori titolo nil))
  35. (define (get-autore-L libro)
  36.         (car libro))
  37. (define (get-titolo-L libro)
  38.         (cadr libro))
  39. (define (get-collocazione-L libro)
  40.         (caddr libro))
  41. (define (set-collocazione-L! libro collocazione)
  42.         (set-car! (cddr libro) collocazione))
  43. (define (input-libro)
  44.         (define aut-lis nil)
  45.         (define titolo nil)
  46.         (writeln "Autori")
  47.         (set! aut-lis (input-aut-lis))
  48.         (set! titolo (read-string "titolo: "))
  49.         (make-libro aut-lis titolo))
  50. (define (input-aut-lis)
  51.         (define nome (input-persona))
  52.         (if (conferma? "un altro autore ? ")
  53.             (merge-aut (list nome) (input-aut-lis))
  54.             (list nome)))
  55. (define (merge-aut x y)
  56.         (cond ((null? x) y)
  57.               ((null? y) x)
  58.               ((persona<=? (car y) (car x))
  59.                (cons (car x) (merge-aut (cdr x) y)))
  60.               (else (cons (car y) (merge-aut x (cdr y))))))
  61. (define (output-aut-lis aut-lis)
  62.         (for-each output-persona aut-lis))
  63. (define (output-libro libro)
  64.         (writeln "titolo : " (get-titolo-L libro))
  65.         (writeln "Autori")
  66.         (output-aut-lis (get-autore-L libro))
  67.         (newline)
  68.         (writeln "collocazione : " (get-collocazione-L libro)))
  69. (define titolo=? string-CI=?)
  70. (define data=? =)
  71. (define data<=? <=)
  72. (define collocazione=? string=?)
  73. (define (aut-lis=? aut1 aut2)
  74.         (cond ((and (null? aut1) (null? aut2)) #t)
  75.               ((null? aut1) #f)
  76.               ((null? aut2) #f)
  77.               ((persona=? (car aut1) (car aut2))
  78.                 (aut-lis=? (cdr aut1) (cdr aut2)))
  79.               (else #f)))
  80. (define (aut-lis<=? aut1 aut2)
  81.         (cond ((and (null? aut1) (null? aut2)) #t)
  82.               ((null? aut1) #f)
  83.               ((null? aut2) #t)
  84.               ((persona=? (car aut1) (car aut2))
  85.                 (aut-lis<=? (cdr aut1) (cdr aut2)))
  86.               (else (persona<=? (car aut1) (car aut2)))))
  87. (define (make-volume libro data casa-ed)
  88.         (list libro data casa-ed nil))
  89. (define (get-libro-V volume)
  90.         (car volume))
  91. (define (get-data-V volume)
  92.         (cadr volume))
  93. (define (get-casa-ed-V volume)
  94.         (caddr volume))
  95. (define (get-prestiti-V volume)
  96.         (cadddr volume))
  97. (define (get-last-pres-V volume)
  98.         (car (cadddr volume)))
  99. (define (add-prestito-V! volume data)
  100.         (set-car! (cdddr volume) (cons data (cadddr volume))))
  101. (define (output-volume volume)
  102.         (define da-re (get-data-res-D (get-last-pres-V volume)))
  103.         (newline)
  104.         (output-libro (get-libro-V volume))
  105.         (writeln "data di pubblicazione : " (get-data-V volume))
  106.         (writeln "casa editrice : " (get-casa-ed-V volume))
  107.         (if (or (null? da-re) (data? da-re))
  108.             (writeln "Disponibile per il prestito")
  109.             (writeln "In prestito dal "
  110.                      (get-data-pre-D (get-last-pres-V volume)))))
  111. (define (input-volume)
  112.         (define libro (input-libro))
  113.         (define data (read-number "data di pubblicazione: "))
  114.         (define casa (read-string "casa editrice: "))
  115.         (make-volume libro data casa))
  116. (define (volume-autore=? volume1 volume2)
  117.         (aut-lis=? (get-autore-L (get-libro-V volume1))
  118.                    (get-autore-L (get-libro-V volume2))))
  119. (define (volume-autore<=? volume1 volume2)
  120.         (aut-lis<=? (get-autore-L (get-libro-V volume1))
  121.                     (get-autore-L (get-libro-V volume2))))
  122. (define (volume=? volume1 volume2)
  123.         (and (aut-lis=? (get-autore-L (get-libro-V volume1))
  124.                         (get-autore-L (get-libro-V volume2)))
  125.              (titolo=? (get-titolo-L (get-libro-V volume1))
  126.                        (get-titolo-L (get-libro-V volume2)))
  127.              (data=? (get-data-V volume1)
  128.                      (get-data-V volume2))))
  129. (define (make-utente persona indirizzo)
  130.         (list persona indirizzo (cons nil nil)))
  131. (define (get-persona-U utente)
  132.         (car utente))
  133. (define (get-indirizzo-U utente)
  134.         (cadr utente))
  135. (define (get-prestiti-U utente)
  136.         (cdaddr utente))
  137. (define (find-pres-U collocazione utente)
  138.         (define (F-P-U n p)
  139.                 (if (null? p)
  140.                     nil
  141.                     (if (collocazione=? collocazione
  142.                                         (get-collocazione-L (get-libro-P (car p))))
  143.                         n
  144.                         (F-P-U (1+ n) (cdr p)))))
  145.         (F-P-U 0 (get-prestiti-U utente)))
  146. (define (get-pres-U n utente)
  147.         (list-ref (cdaddr utente) n))
  148. (define (rem-pres-U! n utente)
  149.         (if (= n 0)
  150.             (set-cdr! (caddr utente)
  151.                       (cdr (cdaddr utente)))
  152.             (set-cdr! (list-tail (cdaddr utente) (-1+ n))
  153.                       (list-tail (cdaddr utente) n))))
  154. (define (get-restituiti-U utente)
  155.         (cdaddr utente))
  156. (define (add-prestiti-U! restituito utente)
  157.         (set-cdr! (caddr utente) (cons restituito (cdaddr utente))))
  158. (define (add-restituiti-U! prestito utente)
  159.         (set-car! (caddr utente) (cons prestito (caaddr utente))))
  160. (define (input-utente)
  161.         (define persona (input-persona))
  162.         (define indirizzo (read-string "indirizzo: "))
  163.         (make-utente persona indirizzo))
  164. (define (output-prestiti prestiti)
  165.         (if (null? prestiti)
  166.             nil
  167.             (begin (output-libro (get-libro-P (car prestiti)))
  168.                    (writeln "Prestato il "
  169.                             (get-data-pre-D (get-data-P (car prestiti))))
  170.                    (output-prestiti (cdr prestiti)))))
  171. (define (output-utente utente)
  172.         (newline)
  173.         (output-persona (get-persona-U utente))
  174.         (writeln "indirizzo : " (get-indirizzo-U utente))
  175.         (writeln "libri attualmente in prestito : "
  176.                  (length (get-prestiti-U utente))))
  177. (define (utente=? utente1 utente2)
  178.         (persona=? (get-persona-U utente1)
  179.                    (get-persona-U utente2)))
  180. (define (utente<=? utente1 utente2)
  181.         (persona<=? (get-persona-U utente1)
  182.                     (get-persona-U utente2)))
  183. (define (make-prestito libro data)
  184.         (cons libro data))
  185. (define (get-libro-P prestito)
  186.         (car prestito))
  187. (define (get-data-P prestito)
  188.         (cdr prestito))
  189. (define (make-data data-pre data-res)
  190.         (cons data-pre data-res))
  191. (define (get-data-pre-D data)
  192.         (car data))
  193. (define (get-data-res-D data)
  194.         (cdr data))
  195. (define (set-data-res-D! data data-res)
  196.         (set-cdr! data data-res))
  197. (define data<=? <=)
  198. (define (data? data)
  199.         (number? data))
  200. (define (make-biblio arc pos)
  201.         (list 'archivio arc pos (arc 'us-data nil)))
  202. (define (get-arc v)
  203.         (cadr v))
  204. (define (get-pos v)
  205.         (caddr v))
  206. (define (get-data v)
  207.         (cadddr  v))
  208. (define (set-data! v p)
  209.         (set-car! (cdddr (cdr v)) p))
  210. (define (get-next-col v)
  211.         (caddr (get-data v)))
  212. (define (get-type v)
  213.         (car (get-data v)))
  214. (define (get-sigla v)
  215.         (cadr (get-data v)))
  216. (define (set-pos! v p)
  217.         (set-car! (cddr v) p))
  218. (define (set-next-col! v p)
  219.         (set-car! (cddr (get-data v)) p))
  220. (define (archivio? val)
  221.         (and (pair? val) (eq? (car val) 'archivio)))
  222. (define (conferma? messaggio)
  223.         (define risposta nil)
  224.         (display messaggio)
  225.         (set! risposta (read))
  226.         (or (eq? risposta 'y)
  227.             (eq? risposta 's)))
  228. (define (read-string text)                                                                         ;
  229.         (do ((lettura (begin (display text)
  230.                              (read))
  231.                       (begin (display text)
  232.                              (read))))
  233.             ((string? lettura) lettura)
  234.             (writeln "il dato richiesto deve essere una stringa")))
  235. (define (read-number text)
  236.         (do ((lettura (begin (display text)
  237.                              (read))
  238.                       (begin (display text)
  239.                              (read))))
  240.             ((number? lettura) lettura)
  241.             (writeln "il dato richiesto deve essere un numero")))))
  242.  
  243.